COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(*$E+ routines to allocate & release the various data blocks used by AL programs *)
C00004 00003	(* Global variables to keep track of things *)
C00005 00004	(* initAlloc & showAlloc *)
C00007 00005	(* Internal routines to fool the compiler *)
C00011 00006	(* External routines to allocate & free up nodes *)
C00016 ENDMK
C⊗;
(*$E+ routines to allocate & release the various data blocks used by AL programs *)

program alloc;

type 
    u = (used,free);
    vectorp = ↑vector;
    vector = record case u of
	       used: (refcnt: integer; val: array [1..3] of real);
	       free: (next: vectorp);
	     end;

    transp = ↑trans;
    trans = record case u of
	       used: (refcnt: integer; val: array [1..3,1..4] of real);
	       free: (next: transp);
	    end;

    nodep = ↑node;
    node = record next: nodep; filler: array [1..6] of integer; end; (* 1..5 *)

(* the following get used for misc record types - i.e. we fake out Pascal's type
	checking mechanism *)

     s4p = ↑s4;
     s4 = record next: s4p; filler: array [1..3] of integer; end;
     s8p = ↑s8;
     s8 = record next: s8p; filler: array [1..7] of integer; end;
     s11p = ↑s11;
     s11 = record next: s11p; filler: array [1..10] of integer; end;

     statementp = ↑statement;
     statement = packed record
		  next, last, stlab, exprs: statementp;
		  nlines: integer;
		  bpt: boolean;
		  filler: array [1..5] of integer;
		  end;

(* Global variables to keep track of things *)

var freeVectors: vectorp;
    freeTrans: transp;
    freeNodes: nodep;
    free4: s4p;
    free8: s8p;
    free10: statementp;
    free11: s11p;
    cv,ct,cn,c4,c8,c10,c11: integer;	(* max number of records allocated *)
    ccv,cct,ccn,cc4,cc8,cc10,cc11: integer;	(* current # in use *)

(* initAlloc & showAlloc *)

procedure initAlloc;
begin
 freeVectors := nil;
 freeTrans := nil;
 freeNodes := nil;
 free4 := nil;
 free8 := nil;
 free10 := nil;
 free11 := nil;
 cv := 0; ccv := 0;
 ct := 0; cct := 0;
 cn := 0; ccn := 0;
 c4 := 0; cc4 := 0;
 c8 := 0; cc8 := 0;
 c10 := 0; cc10 := 0;
 c11 := 0; cc11 := 0; 
end;

procedure showAlloc;
 begin
 writeln('size		current # in use / # allocated');
 writeln;
 writeln('vector	',ccv,'/',cv);
 writeln('trans		',cct,'/',ct);
 writeln('node		',ccn,'/',cn);
 writeln('s4		',cc4,'/',c4);
 writeln('s8		',cc8,'/',c8);
 writeln('s10		',cc10,'/',c10);
 writeln('s11		',cc11,'/',c11);
 writeln;
 writeln;
 end;

(* Internal routines to fool the compiler *)

function new4: s4p;
 var n: s4p;
 begin
 cc4 := cc4 + 1;
 n := free4;
 if n = nil then
   begin
   new(n);
   c4 := c4 + 1;
   end
  else free4 := n↑.next;
 new4 := n;
 end;

procedure rel4(n: s4p);
 begin
 cc4 := cc4 - 1;
 n↑.next := free4;
 free4 := n;
 end;

function new8: s8p;
 var n: s8p;
 begin
 cc8 := cc8 + 1;
 n := free8;
 if n = nil then
   begin
   new(n);
   c8 := c8 + 1;
   end
  else free8 := n↑.next;
 new8 := n;
 end;

procedure rel8(n: s8p);
 begin
 cc8 := cc8 - 1;
 n↑.next := free8;
 free8 := n;
 end;

function new10: statementp;
 var n: statementp;
 begin
 cc10 := cc10 + 1;
 n := free10;
 if n = nil then
   begin
   new(n);
   c10 := c10 + 1;
   end
  else free10 := n↑.next;
 new10 := n;
 end;

procedure rel10(n: statementp);
 begin
 cc10 := cc10 - 1;
 n↑.next := free10;
 free10 := n;
 end;

function new11: s11p;
 var n: s11p;
 begin
 cc11 := cc11 + 1;
 n := free11;
 if n = nil then
   begin
   new(n);
   c11 := c11 + 1;
   end
  else free11 := n↑.next;
 new11 := n;
 end;

procedure rel11(n: s11p);
 begin
 cc11 := cc11 - 1;
 n↑.next := free11;
 free11 := n;
 end;

(* External routines to allocate & free up nodes *)

function newVector: vectorp;
 var v: vectorp;
 begin
 ccv := ccv + 1;
 v := freeVectors;
 if v = nil then
   begin
   new(v);
   cv := cv + 1;
   end
  else freeVectors := v↑.next;
 v↑.refcnt := 0;
 newVector := v;
 end;

procedure relVector(v: vectorp);
 begin
 ccv := ccv - 1;
 v↑.next := freeVectors;
 freeVectors := v;
 end;

function newTrans: transp;
 var t: transp;
 begin
 cct := cct + 1;
 t := freeTrans;
 if t = nil then
   begin
   new(t);
   ct := ct + 1;
   end
  else freeTrans := t↑.next;
 t↑.refcnt := 0;
 newTrans := t;
 end;

procedure relTrans(t: transp);
 begin
 cct := cct - 1;
 t↑.next := freeTrans;
 freeTrans := t;
 end;

function newNode: nodep;
 var n: nodep;
 begin
 ccn := ccn + 1;
 n := freeNodes;
 if n = nil then
   begin
   new(n);
   cn := cn + 1;
   end
  else freeNodes := n↑.next;
 n↑.next := nil;
 newNode := n;
 end;

procedure relNode(n: nodep);
 begin
 ccn := ccn - 1;
 n↑.next := freeNodes;
 freeNodes := n;
 end;

function newEvent: s4p; begin newEvent := new4; end;
procedure relEvent(n: s4p); begin rel4(n); end;

function newEentry: s4p; begin newEentry := new4; end;
procedure relEentry(n: s4p); begin rel4(n); end;

function newToken: s4p; begin newToken := new4; end;
procedure relToken(n: s4p); begin rel4(n); end;

function newIdent: s4p; begin newIdent := new4; end;
procedure relIdent(n: s4p); begin rel4(n); end;

function newStrng: nodep; begin newStrng := newnode; end;
procedure relStrng(n: nodep); begin relnode(n); end;

function newCmoncb: nodep; begin newCmoncb := newnode; end;
procedure relCmoncb(n: nodep); begin relnode(n); end;

function newVaridef: s8p; begin newVaridef := new8; end;
procedure relVaridef(n: s8p); begin rel8(n); end;

function newFrame: s8p; begin newFrame := new8; end;
procedure relFrame(n: s8p); begin rel8(n); end;

function newEheader: s8p; begin newEheader := new8; end;
procedure relEheader(n: s8p); begin rel8(n); end;

function newStatement: statementp;
 var s: statementp;
 begin
 s := new10;
 with s↑ do
  begin next := nil; last := nil; stlab := nil; exprs := nil; bpt := false;
	nlines := 1; end;
 newStatement := s;
 end;
procedure relStatement(n: statementp); begin rel10(n); end;

function newPdb: s8p; begin newPdb := new8; end;
procedure relPdb(n: s8p); begin rel8(n); end;

function newEnvironment: s11p; begin newEnvironment := new11; end;
procedure relEnvironment(n: s11p); begin rel11(n); end;

begin
end.